{-
    pHaskell Translator v0.1 
    Copyright (C) 2009  Ruben Marcelo Caro 

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see [http://www.gnu.org/licenses/>.
-}
module TemplateRender where
import TemplatesTypes
import List

getVarName (MetaVariable var)  = var
getVarName _                   = ""

{- Neceario para ordenar listas de MetaTreeExp -}
variablesFirst::Context-> MetaTreeExp-> MetaTreeExp-> Ordering
variablesFirst cs (MetaNode ((MetaVariable varName), _) _) mt2 = case isTypeConstructor cs varName of
																False-> GT  --ACA!!
																True -> LT
variablesFirst _ _ _                                           = LT



{-
Chequea si algun elemento de la lista es una variable
-}
haveSomeVariable::Context-> [MetaTreeExp]-> Bool
haveSomeVariable cs []                                            = False
																   --Ojo: si es un type constructor, no es una variable
haveSomeVariable cs ((MetaNode ((MetaVariable varName), _) _):ts) = case isTypeConstructor cs varName of
																		True  -> haveSomeVariable cs ts
																		False -> True
																
haveSomeVariable cs (t:ts)                                        = haveSomeVariable cs ts
				
   									
{-
Genera un String ID Unico a partir de un contexto
-}
buildUnikePostFix::Context-> String
buildUnikePostFix ([],_,_)      = ""
buildUnikePostFix ((p:ps),_, _) = show p++"_"++ buildUnikePostFix (ps,[],[])
									     
spaces::Int-> String									
spaces n = concat (take n (repeat " ")) 

{-
Pone la cascara de struct y pasa a renderListMetaTreeExp
-}
renderMetaFunction::Context-> Int-> MetaFunction-> String
renderMetaFunction cs  n  (MetaFunction funcName mtes) =  "\n" 
														++ (spaces n) ++"struct "++funcName++"\n"
                                                        ++ (spaces n) ++ "{\n" 
                                                                      ++ renderListMetaTreeExp cs mtes (n+4)
                                                        ++ (spaces n) ++ "};\n" 
                                                                               	
                                                                               	    
                                                                               
renderListMetaTreeExp::Context-> [MetaTreeExp]-> Int-> String
renderListMetaTreeExp cs []  n = ""
renderListMetaTreeExp cs mst n =  case  isEagerMatching mst of
										True  -> makeMattchingShell (concat (map (renderMetaTreeExpMatching "_matching" cs (n+2)) mst'') ) isConstructorType  n      --eager bridge
										False -> makeNoMattchingShell (isLeaft mst) (concat (map (renderMetaTreeExpMatching "" cs (n+2)) mst) ) n  --lazy approach
									where 
										isLeaft ((MetaLeaft _ _):ts) = True
										isLeaft ts 					 = False
										--isEagerMatching True si tiene mas de un matching, y en caso de 
										--tener solo uno, debuelve true si no es un leaft y no tiene variable asociada
										isEagerMatching::[MetaTreeExp]-> Bool
										isEagerMatching subTrees = (length subTrees) > 1 || ((length subTrees) == 1 && not (haveSomeVariable cs subTrees) && not (isLeaft subTrees)) 
										mst'' = sortBy (variablesFirst cs) mst
										isConstructorType = existTypeConstructorNode cs mst 
										


{-
Es el cascaron y xs es el MetaTreeExp renderizado
En este caso el cascaron incluye el eager bridge 
y la forward declaration del tamplate app
-}
makeMattchingShell::String-> Bool-> Int-> String
makeMattchingShell xs isDataUser n =       (spaces n) ++ "struct _\n" 
								      	++ (spaces n) ++"{\n"  
								      	++ (spaces n) ++"typedef _ value;\n" 
										-- ++ (spaces n) ++ "template[class> class app;\n\n" //incompatible con comeau
										++ (spaces n) ++ "template< class ,class=void>\n"
    									++ (spaces n) ++ "struct app_matching;\n\n"
										++ (spaces n) ++ "template<class BridgeEager45344>\n"
										++ (spaces n) ++ "struct app:app_matching< "++ bridgeRef ++" > {}; //eager bridge \n\n"
										++ xs 
										++ (spaces n) ++ "};\n"
											where
											  bridgeRef = case isDataUser of
											  				True  -> "typename BridgeEager45344::value"
											  				False -> "typename BridgeEager45344::value"

{-
Es el cascaron y xs es el MetaTreeExp renderizado 
-}
makeNoMattchingShell::Bool-> String-> Int-> String
makeNoMattchingShell False xs n =    (spaces n) ++ "struct _\n" 
					      			++ (spaces n) ++"{\n"  
					      			++ (spaces n) ++"typedef _ value;\n"  
									++ xs 
									++ (spaces n) ++ "};\n"

{-
Si el primer parametro es un leaft entonces no hay que envolverlo
-}
makeNoMattchingShell True xs n = xs

{-
Construye todos los app_matching
-}
renderMetaTreeExpMatching::String-> Context-> Int-> MetaTreeExp-> String
renderMetaTreeExpMatching matchingName cs n (MetaNode (e, t) localTrees) =      (spaces n) ++ "template< "++(buildTemplateHeader isMatching cs' e t)++">\n"
																++ (spaces n) ++ "struct app"++ matchingName ++ buildTemplateSpecialization cs' e t ++"\n"
																++ (spaces n) ++ "{\n"
																              ++ renderListMetaTreeExp cs' localTrees (n+2) 
																++ (spaces n) ++ "};\n"
																where
																    --Agrego todas las variables de la exprecion como variable bindeada
	                                       							cs'        = addListBinded newBinded (addParent PMetaLambda cs)
	                                       							newBinded  = getAllVariables cs e
	                                       							isMatching = matchingName /= ""
	                                       							

   
renderMetaTreeExpMatching matchingName cs n leaft@(MetaLeaft e localProgram)   = renderMetaLeaft cs leaft n

buildTemplateHeader::Bool-> Context-> MetaExp-> MetaType-> String
buildTemplateHeader isMatching cs v@(MetaVariable var)  t = case isTypeConstructorVariable cs v of
	                                                  False -> "class " ++ var ++ ", "++"class" ++ (defaultValue isMatching)
	                                                  True  -> "class dummy_"++buildUnikePostFix cs
                                                  	where
                                                  		defaultValue True  = ""
                                                  		defaultValue False = "=void"
                                                  
buildTemplateHeader _ cs (MetaBoolean bool)  t = "class dummy_"++buildUnikePostFix cs
buildTemplateHeader _ cs (MetaInteger integ) t = "class dummy_"++buildUnikePostFix cs																
buildTemplateHeader _ cs (MetaTypeConstructor name expr ) ts = renderVariableList (allVariables++[dummyVar])    
																where 
																	allVariables = concat (map (getAllVariables cs) expr)
																	dummyVar = "dummy_"++(buildUnikePostFix cs)															
buildTemplateHeader _ cs e t = " -invalid: " ++ show e

renderVariableList::[String]-> String
renderVariableList   [ ]     = ""
renderVariableList   [x]     = "class "++x
renderVariableList  (x:xs)   = "class "++x++", " ++ (renderVariableList xs)



buildTemplateSpecialization::Context-> MetaExp-> MetaType-> String
buildTemplateSpecialization cs v@(MetaVariable var) t  = ""--"[ "++ var ++ ", "++"dummy_"++(buildUnikePostFix cs) ++ " >"
buildTemplateSpecialization cs (MetaBoolean bool) t  =  "< Bool<" ++bool++">, dummy_"++ buildUnikePostFix cs ++">"
buildTemplateSpecialization cs (MetaInteger integ) t =  "< Int<" ++integ++">, dummy_"++ buildUnikePostFix cs ++">"																																

--Ver si es un matching puro o no
buildTemplateSpecialization cs tctor@(MetaTypeConstructor name expr ) t = "< "++ (renderMetaExp cs' 0 tctor ) ++ ", "++ dummyVar ++" >" 
																	where
																		dummyVar = "dummy_"++ buildUnikePostFix cs
																		cs' =  addParent PMetaPatternMatching cs


buildTemplateSpecialization cs x t = error (show x)

getAllVariables::Context-> MetaExp-> [String]
getAllVariables cs (MetaApp e e')     = (getAllVariables cs e) ++ (getAllVariables cs e')  
getAllVariables cs (MetaVariable var) =  [var]
getAllVariables cs (MetaTypeConstructor name exprs) =  concat (map (getAllVariables cs) exprs) 
getAllVariables cs  e = []





--renderConstructionType::[MetaExp]-> Context-> String
--renderConstructionType:: (MetaVariable varName) cs = "varName" 

--Traduce un arbol de meta exp en una lista como se leeria
{-
treeApp2ListApp::MetaExp-> [MetaExp]
treeApp2ListApp (MetaApp e e') = (treeApp2ListApp e)++[e'] 
treeApp2ListApp  e             = [e]
-}

{-
llegamos a la hoja, renderiza la exprecion 
y tambien las definiciones locales
-}                                                                               
renderMetaLeaft::Context-> MetaTreeExp-> Int-> String
renderMetaLeaft cs (MetaLeaft e locals) n =     localsRender
												++ (spaces n) ++ "struct _:  "++(renderMetaExp cs' n e )++"\n"
												++ (spaces n) ++ "{\n"
												++ (spaces n) ++   "typedef " ++(renderMetaExp cs'' n e )++"::value value;\n"
												++ (spaces n) ++ "};\n"
														where
															cs'    = addParent PMetaValue cs
															cs''   = addParent PMetaEager cs 
															isTemplate      = hasAncestor PMetaLambda cs
															typename False  = ""
															typename True   = "typename "
															--renderiza todas las funciones locales.                                               					
															localsRender = renderMetaProgramWithInitialContext locals cs n
	                                       					
 


renderList::[String]-> String
renderList   [ ]     = ""
renderList   [x]     = x
renderList  (x:xs)   = x++", " ++ (renderList xs)
									                                                           				    
renderMetaExp::Context-> Int-> MetaExp-> String
renderMetaExp cs n (MetaInteger number)   = "Int<"++number++"> "
renderMetaExp cs n (MetaBoolean bool)     = "Bool<"++bool++"> "
renderMetaExp cs n (MetaTypeConstructor name metaexps)  = (typename (isTemplate && hasFatherEager))++name++"<"++ renderList (map (renderMetaExp cs' n) metaexps)  ++" >" --(typename ( not isMatching && isTemplate && (isUsedAsType || isEager )))++ name++"["++ renderList (map (renderMetaExp cs' n) metaexps)  ++" >"
															where
																cs' = addParent PMetaApp' cs --el entorno es el mismo que si fuera una aplicacion comun y corriente																
																isTemplate      = hasAncestor PMetaLambda cs
																isUsedAsType    = hasAncestor PMetaApp' cs
																isEager         = hasAncestor PMetaEager cs
																hasFatherEager  = (father cs  == PMetaEager) 
																isMatching      = hasAncestor PMetaPatternMatching cs
																typename False  = ""
																typename True   = "typename "
																

renderMetaExp cs n (MetaVariable var)     =   typename ( (typeDefFather && isTemplate)|| (condition1 && isTemplate && (isUsedAsType || isEager)) ) ++ var++(initiator (condition1 )) 
													where
													 	typename False  = ""
														typename True   = "typename "
														initiator False = ""
														initiator True  = "::_"
														isTemplate      = hasAncestor PMetaLambda cs
														isNotBinded     = (not (isBinded var cs) )
														isUsedAsType    = hasAncestor PMetaApp' cs
														isEager         = hasAncestor PMetaEager cs
														isBindedButUsedAsFunction = (isBinded var cs) && (father cs  == PMetaApp)
														condition1 = (isNotBinded || isBindedButUsedAsFunction) -- bindeada pero usada en una plicacion
														typeDefFather= (father cs) == PMetaEager  --all metaeager already have typedef
														--condition2 = (isNotBinded || (isBinded var cs) && isEager) 

renderMetaExp cs n (MetaIf e e' e'')  = (typename (isEager||isUsedAsType)) ++ "IF<" ++  (renderMetaExp cs' (n+10) e ) ++ ", \n"
												++ (spaces (n+10)) ++(renderMetaExp cs' (n+10) e' ) ++ ", \n" 
												++ (spaces (n+10)) ++(renderMetaExp cs' (n+10) e'' ) ++" >::_"
												where
													typename False  = ""
													typename True   = "typename "
													cs'  = addParent PMetaApp' cs
													isEager         = hasAncestor PMetaEager cs
													isUsedAsType    = hasAncestor PMetaApp' cs
						
renderMetaExp cs n (MetaIfOnly e e')  = (typename (isEager||isUsedAsType)) ++ "IF<" ++  (renderMetaExp cs' n e ) ++ ", \n" 
                                                ++ (spaces (n+20)) ++(renderMetaExp cs' n e' ) ++ " >::_"
												where
													typename False  = ""
													typename True   = "typename "
													cs'  = addParent PMetaApp' cs
													isEager         = hasAncestor PMetaEager cs
													isUsedAsType    = hasAncestor PMetaApp' cs



renderMetaExp cs n app@(MetaApp e e')    = (renderMetaExp cs' n e ) ++"::"++(template isTemplate)++"app<"++ (renderMetaExp cs'' n e' )++" >"++"::_"    
													where
													  cs'' = addParent PMetaApp' cs 
													  cs'  = addParent PMetaApp  cs
													  template False  = ""
													  template True   = "template "
													  isTemplate =  hasAncestor PMetaLambda cs
										
{-
Entry Point
Basicament map -> renderMetaFunction sobre cada MetaFunction
-}
renderMetaProgramWithInitialContext::MetaProgram-> Context-> Int-> String
renderMetaProgramWithInitialContext templateProgram cs n = concat (map (renderMetaFunction cs n) templateProgram)



													
													  

 

